Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH5/SRC/TWEENEND.FRM

Visual Basic Form | 1996-05-02 | 24.4 KB | 777 lines

VERSION 4.00
Begin VB.Form TweenForm
   Caption         =   "TweenEnd"
   ClientHeight    =   4590
   ClientLeft      =   2040
   ClientTop       =   1035
   ClientWidth     =   4635
   Height          =   5280
   Left            =   1980
   LinkTopic       =   "Form1"
   ScaleHeight     =   306
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   309
   Top             =   405
   Width           =   4755
   Begin VB.CommandButton CmdTween
      Caption         =   "Tween"
      Height          =   495
      Left            =   3480
      TabIndex        =   12
      Top             =   480
      Width           =   975
   End
   Begin VB.TextBox TweensText
      Height          =   285
      Left            =   4200
      TabIndex        =   10
      Text            =   "4"
      Top             =   0
      Width           =   375
   End
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   4080
      TabIndex        =   9
      Text            =   "20"
      Top             =   1800
      Width           =   375
   End
   Begin VB.CommandButton CmdPlay
      Caption         =   "Play"
      Default         =   -1  'True
      Height          =   495
      Left            =   3480
      TabIndex        =   7
      Top             =   3480
      Width           =   975
   End
   Begin VB.OptionButton PlayOption
      Caption         =   "Reversing"
      Height          =   255
      Index           =   2
      Left            =   3360
      TabIndex        =   4
      Top             =   3000
      Width           =   1095
   End
   Begin VB.OptionButton PlayOption
      Caption         =   "Looping"
      Height          =   255
      Index           =   1
      Left            =   3360
      TabIndex        =   3
      Top             =   2640
      Width           =   1095
   End
   Begin VB.OptionButton PlayOption
      Caption         =   "Once"
      Height          =   255
      Index           =   0
      Left            =   3360
      TabIndex        =   2
      Top             =   2280
      Value           =   -1  'True
      Width           =   1095
   End
   Begin VB.HScrollBar SBar
      Height          =   255
      Left            =   0
      Max             =   1
      Min             =   1
      TabIndex        =   1
      Top             =   3960
      Value           =   1
      Width           =   3255
   End
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      Height          =   3975
      Left            =   0
      ScaleHeight     =   261
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   213
      TabIndex        =   0
      Top             =   0
      Width           =   3255
   End
   Begin VB.Label Label1
      Caption         =   "Tweens:"
      Height          =   255
      Index           =   2
      Left            =   3360
      TabIndex        =   11
      Top             =   0
      Width           =   615
   End
   Begin VB.Label Label1
      Caption         =   "FPS:"
      Height          =   255
      Index           =   1
      Left            =   3480
      TabIndex        =   8
      Top             =   1800
      Width           =   375
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   2640
      Top             =   4200
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label FrameLabel
      Alignment       =   2  'Center
      BorderStyle     =   1  'Fixed Single
      Caption         =   "1/1"
      Height          =   255
      Left            =   1680
      TabIndex        =   6
      Top             =   4320
      Width           =   735
   End
   Begin VB.Label Label1
      Caption         =   "Frame:"
      Height          =   255
      Index           =   0
      Left            =   1080
      TabIndex        =   5
      Top             =   4320
      Width           =   495
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSave
         Caption         =   "&Save"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "Save &As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep1
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileNew
         Caption         =   "&New"
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuFileSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuFrame
      Caption         =   "Frame"
      Begin VB.Menu mnuFrameAfter
         Caption         =   "Insert &After"
      End
      Begin VB.Menu mnuFrameBefore
         Caption         =   "Insert &Before"
      End
      Begin VB.Menu mnuFrameSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFrameClear
         Caption         =   "&Clear"
      End
      Begin VB.Menu mnuFrameDelete
         Caption         =   "&Delete"
         Enabled         =   0   'False
      End
   End
Attribute VB_Name = "TweenForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim NumFrames As Integer
Dim Frames() As PolylineFrame
Dim FileLoaded As String
Dim DataModified As Boolean
Dim Playing As Boolean
Dim SelectedFrame As Integer
Dim SelectingFrame As Boolean
Dim Drawing As Boolean
Dim StartX As Integer
Dim StartY As Integer
Dim LastX As Integer
Dim LastY As Integer
' ************************************************
' Insert a frame next to the selected one.
' ************************************************
Private Sub AddFrame()
Dim i As Integer
    NumFrames = NumFrames + 1
    ReDim Preserve Frames(1 To NumFrames)
    For i = NumFrames - 1 To SelectedFrame Step -1
        CopyFrame i, i + 1
    Next i
    SBar.Max = NumFrames
    mnuFrameDelete.Enabled = (NumFrames > 1)
    DataModified = True
End Sub
' ************************************************
' Copy a polyline from frame1 to frame2.
' ************************************************
Sub CopyFrame(frame1 As Integer, frame2 As Integer)
Dim pline As Integer
Dim point As Integer
    Frames(frame2).NumPolylines = Frames(frame1).NumPolylines
    If Frames(frame2).NumPolylines < 1 Then
        Erase Frames(frame2).Poly
    Else
        ReDim Frames(frame2).Poly(1 To Frames(frame2).NumPolylines)
    End If
    For pline = 1 To Frames(frame2).NumPolylines
        With Frames(frame2).Poly(pline)
            .NumPoints = Frames(frame1).Poly(pline).NumPoints
            If .NumPoints < 1 Then
                Erase .X
                Erase .Y
            Else
                ReDim .X(1 To .NumPoints)
                ReDim .Y(1 To .NumPoints)
            End If
            For point = 1 To .NumPoints
                .X(point) = Frames(frame1).Poly(pline).X(point)
                .Y(point) = Frames(frame1).Poly(pline).Y(point)
            Next point
        End With
    Next pline
End Sub
' ************************************************
' Return true if the data has not been modified,
' or the user has saved the changes, or the user
' wants to lose the changes.
' ************************************************
Function DataSafe() As Boolean
Dim ans As Integer
    Do While DataModified
        ans = MsgBox("The data has been modified." & _
            " Do you want to save the changes?", _
            vbYesNoCancel)
        If ans = vbCancel Then Exit Do
        If ans = vbNo Then
            DataSafe = True
            Exit Function
        End If

        ' Otherwise save the data.
        If FileLoaded <> "" Then
            mnuFileSave_Click
        Else
            mnuFileSaveAs_Click
        End If
    Loop
    DataSafe = Not DataModified
End Function
' ************************************************
' Draw the indicated frame.
' ************************************************
Sub DrawFrame(frame As Integer)
Dim pline As Integer
Dim point As Integer
    Canvas.Cls
    For pline = 1 To Frames(frame).NumPolylines
        With Frames(frame).Poly(pline)
            If .NumPoints >= 2 Then
                Canvas.Line (.X(1), .Y(1))-(.X(2), .Y(2))
                For point = 3 To .NumPoints
                    Canvas.Line -(.X(point), .Y(point))
                Next point
            End If
        End With
    Next pline
End Sub
' ************************************************
' Save the data.
' ************************************************
Sub SaveData(fname As String)
Dim fnum As Integer
Dim frame As Integer
Dim pline As Integer
Dim point As Integer
    On Error GoTo SaveDataError
    ' Open the file.
    fnum = FreeFile
    Open fname For Output As fnum
    ' Save the number of frames.
    Write #fnum, NumFrames
    ' Save each frame.
    For frame = 1 To NumFrames
        With Frames(frame)
            ' Save the number of polylines.
            Write #fnum, .NumPolylines

            ' Save each polyline.
            For pline = 1 To .NumPolylines
                With .Poly(pline)
                    ' Save the number of points.
                    Write #fnum, .NumPoints
                    For point = 1 To .NumPoints
                        Write #fnum, .X(point), .Y(point)
                    Next point
                End With
            Next pline
        End With
    Next frame
    Close fnum
    FileLoaded = fname
    Caption = "TweenEnd [" & fname & "]"
    DataModified = False
    Exit Sub
SaveDataError:
    Beep
    MsgBox "Error saving file " & fname & "." & _
        vbCrLf & Format$(Err.Number) & " : " & _
        Err.Description
    Exit Sub
End Sub
' ************************************************
' Load polyline frames from the file.
' ************************************************
Sub LoadData(fname As String)
Dim fnum As Integer
Dim frame As Integer
Dim pline As Integer
Dim point As Integer
    On Error GoTo SaveDataError
    ' Open the file.
    fnum = FreeFile
    Open fname For Input As fnum
    ' Read the number of frames.
    Input #fnum, NumFrames
    ReDim Frames(1 To NumFrames)
    SBar.Max = NumFrames
    ' Read each frame.
    For frame = 1 To NumFrames
        With Frames(frame)
            ' Read the number of polylines.
            Input #fnum, .NumPolylines
            ReDim .Poly(1 To .NumPolylines)

            ' Read each polyline.
            For pline = 1 To .NumPolylines
                With .Poly(pline)
                    ' Read the number of points.
                    Input #fnum, .NumPoints
                    ReDim .X(1 To .NumPoints)
                    ReDim .Y(1 To .NumPoints)
                    For point = 1 To .NumPoints
                        Input #fnum, .X(point), .Y(point)
                    Next point
                End With
            Next pline
        End With
    Next frame
    Close fnum
    SelectFrame 1
    FileLoaded = fname
    Caption = "TweenEnd [" & fname & "]"
    DataModified = False
    Exit Sub
SaveDataError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Format$(Err.Number) & " : " & _
        Err.Description
    Exit Sub
End Sub
' ************************************************
' Select and display the indicated frame.
' ************************************************
Sub SelectFrame(num As Integer)
    SelectedFrame = num
    ' If we're drawing, stop drawing.
    If Drawing Then
        Canvas.DrawMode = vbCopyPen
        Drawing = False
    End If
    DrawFrame SelectedFrame
    FrameLabel.Caption = Format$(SelectedFrame) _
         & "/" & Format$(NumFrames)
    SelectingFrame = True
    SBar.Value = SelectedFrame
    SelectingFrame = False
End Sub
' ************************************************
' Create the tweens between two key frames using
' endpoint interpolation.
' ************************************************
Sub MakeTweens(key1 As Integer, key2 As Integer)
Dim frac1 As Single
Dim frac2 As Single
Dim tween As Integer
Dim pline As Integer
Dim point As Integer
    For tween = key1 + 1 To key2 - 1
        frac1 = (key2 - tween) / (key2 - key1)
        frac2 = 1# - frac1

        Frames(tween).NumPolylines = Frames(key1).NumPolylines
        ReDim Frames(tween).Poly(1 To Frames(tween).NumPolylines)
        For pline = 1 To Frames(tween).NumPolylines
            With Frames(tween).Poly(pline)
                .NumPoints = Frames(key1).Poly(pline).NumPoints
                ReDim .X(1 To .NumPoints)
                ReDim .Y(1 To .NumPoints)
                For point = 1 To .NumPoints
                    .X(point) = frac1 * Frames(key1).Poly(pline).X(point) + frac2 * Frames(key2).Poly(pline).X(point)
                    .Y(point) = frac1 * Frames(key1).Poly(pline).Y(point) + frac2 * Frames(key2).Poly(pline).Y(point)
                Next point
            End With
        Next pline
    Next tween
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    Canvas.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    Canvas.MousePointer = vbDefault
End Sub
Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Drawing And Button = vbRightButton Then
        ' End the previous polyline.
        Canvas.Line (StartX, StartY)-(LastX, LastY)
        Canvas.DrawMode = vbCopyPen
        Drawing = False
        Exit Sub
    End If
    ' See if this is the start of a new polyline.
    If Drawing Then
        ' Nope. Erase the previous line.
        Canvas.Line (StartX, StartY)-(LastX, LastY)
    Else
        ' Start a new polyline.
        With Frames(SelectedFrame)
            .NumPolylines = .NumPolylines + 1
            ReDim Preserve .Poly(1 To .NumPolylines)
            With .Poly(.NumPolylines)
                .NumPoints = 1
                ReDim .X(1 To 1)
                ReDim .Y(1 To 1)
                .X(1) = X
                .Y(1) = Y
            End With
        End With
        Canvas.DrawMode = vbInvert
        Drawing = True
        DataModified = True
        StartX = X
        StartY = Y
    End If
    LastX = X
    LastY = Y
    Canvas.Line (StartX, StartY)-(LastX, LastY)
End Sub
Private Sub Canvas_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not Drawing Then Exit Sub
    Canvas.Line (StartX, StartY)-(LastX, LastY)
    LastX = X
    LastY = Y
    Canvas.Line (StartX, StartY)-(LastX, LastY)
End Sub
Private Sub Canvas_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not Drawing Then Exit Sub
    Canvas.Line (StartX, StartY)-(LastX, LastY)
    Canvas.DrawMode = vbCopyPen
    Canvas.Line (StartX, StartY)-(X, Y)
    Canvas.DrawMode = vbInvert
    With Frames(SelectedFrame)
        With .Poly(.NumPolylines)
            .NumPoints = .NumPoints + 1
            ReDim Preserve .X(1 To .NumPoints)
            ReDim Preserve .Y(1 To .NumPoints)
            .X(.NumPoints) = X
            .Y(.NumPoints) = Y
        End With
    End With
    DataModified = True
    StartX = X
    StartY = Y
End Sub
' ************************************************
' Play the animation.
' ************************************************
Private Sub CmdPlay_Click()
    If Playing Then
        Playing = False
        CmdPlay.Caption = "Stopped"
        CmdPlay.Enabled = False
    Else
        Playing = True
        CmdPlay.Caption = "Stop"
        PlayData
        CmdPlay.Caption = "Play"
        Playing = False
        CmdPlay.Enabled = True
        DrawFrame SelectedFrame
    End If
End Sub
' ************************************************
' Play the animation.
' ************************************************
Sub PlayData()
Dim mpf As Long     ' Milliseconds per frame.
Dim frame As Integer
Dim next_time As Long
Dim play_type As Integer
Dim num As Integer
Dim start_time As Single
Dim stop_time As Single
    ' See how fast we should go.
    If Not IsNumeric(FPSText.Text) Then _
        FPSText.Text = "10"
    mpf = 1000 \ CLng(FPSText.Text)
    ' See what kind of animation this should be.
    For play_type = 0 To 2
        If PlayOption(play_type).Value Then Exit For
    Next play_type
    If play_type > 2 Then play_type = 0
    ' Start the animation.
    start_time = Timer
    next_time = GetTickCount()
    Do While Playing
        ' Show the frames.
        For frame = 1 To NumFrames
            If Not Playing Then Exit Do
            num = num + 1

            ' Draw the frame.
            DrawFrame frame

            ' Wait until it's time for the next frame.
            next_time = next_time + mpf
            WaitTill next_time
        Next frame
        ' If this is a one time deal, stop now.
        If play_type = 0 Then Exit Do

        ' If this is a reversing run, go backwards.
        If play_type = 2 Then
            For frame = NumFrames - 1 To 2 Step -1
                If Not Playing Then Exit Do
                num = num + 1

                ' Draw the frame.
                DrawFrame frame

                ' Wait until it's time for the next frame.
                next_time = next_time + mpf
                WaitTill next_time
            Next frame
        End If
    Loop
    stop_time = Timer
    MsgBox "Displayed" & Str$(num) & _
        " frames in " & _
        Format$(stop_time - start_time, "0.00") & _
        " seconds (" & _
        Format$(num / (stop_time - start_time), "0.00") & _
        " FPS)."
End Sub
' ************************************************
' Make the tweens.
' ************************************************
Private Sub CmdTween_Click()
Dim num_tweens As Integer
Dim old_frames As Integer
Dim frame1 As Integer
Dim frame2 As Integer
Dim frame As Integer
    ' See how many tweens to make.
    If Not IsNumeric(TweensText.Text) Then _
        TweensText.Text = "4"
    num_tweens = TweensText.Text
    If num_tweens < 1 Then num_tweens = 1
    ' Make room for the new frames.
    old_frames = NumFrames
    NumFrames = num_tweens * (NumFrames - 1) + NumFrames
    ReDim Preserve Frames(1 To NumFrames)
    ' Spread the original frames out.
    For frame = old_frames To 2 Step -1
        CopyFrame frame, _
            num_tweens * (frame - 1) + frame
    Next frame
    ' Make the tweens.
    For frame = 1 To old_frames - 1
        frame1 = num_tweens * (frame - 1) + frame
        frame2 = frame1 + num_tweens + 1
        MakeTweens frame1, frame2
    Next frame
    SBar.Max = NumFrames
    SelectFrame num_tweens * (SelectedFrame - 1) + _
        SelectedFrame
    DataModified = True
End Sub
Private Sub Form_Load()
    ' Position the scroll bar.
    SBar.Top = Canvas.Top + Canvas.Height + 1
    ' Create an empty frame.
    mnuFileNew_Click
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Cancel = Not DataSafe()
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ************************************************
' Load a data file.
' ************************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    If Not DataSafe() Then Exit Sub
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.FilterIndex = 1
    FileDialog.filename = "*.TWE"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the data file.
    WaitStart
    LoadData fname
    WaitEnd
    FrameLabel.Caption = Format$(SelectedFrame) _
         & "/" & Format$(NumFrames)
End Sub
' ************************************************
' Clear out all the data.
' ************************************************
Private Sub mnuFileNew_Click()
    If Not DataSafe() Then Exit Sub
    NumFrames = 1
    ReDim Frames(1 To NumFrames)
    Frames(1).NumPolylines = 0
    SBar.Max = NumFrames
    SelectFrame 1
End Sub
' ************************************************
' Save the data file.
' ************************************************
Private Sub mnuFileSave_Click()
    If FileLoaded = "" Then
        mnuFileSaveAs_Click
        Exit Sub
    End If
    WaitStart
    SaveData FileLoaded
    WaitEnd
End Sub
' ************************************************
' Save the data file with a new name.
' ************************************************
Private Sub mnuFileSaveAs_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.FilterIndex = 1
    FileDialog.filename = "*.TWE"
    FileDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    FileDialog.ShowSave
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Save the script file.
    WaitStart
    SaveData fname
    WaitEnd
End Sub
' ************************************************
' Insert a frame after the selected one.
' ************************************************
Private Sub mnuFrameAfter_Click()
    AddFrame
    SelectFrame SelectedFrame + 1
End Sub
' ************************************************
' Insert a frame before the selected one.
' ************************************************
Private Sub mnuFrameBefore_Click()
    AddFrame
    FrameLabel.Caption = Format$(SelectedFrame) & "/" & Format$(NumFrames)
End Sub
' ************************************************
' Remove the polylines from the selected frame.
' ************************************************
Private Sub mnuFrameClear_Click()
Dim i As Integer
    With Frames(SelectedFrame)
        .NumPolylines = 0
        Erase .Poly
    End With
    SelectFrame SelectedFrame
    DataModified = True
End Sub
' ************************************************
' Delete the selected frame.
' ************************************************
Private Sub mnuFrameDelete_Click()
Dim i As Integer
    For i = SelectedFrame To NumFrames - 1
        CopyFrame i + 1, i
    Next i
    NumFrames = NumFrames - 1
    ReDim Preserve Frames(1 To NumFrames)
    SBar.Max = NumFrames
    If SelectedFrame > NumFrames Then _
       SelectedFrame = NumFrames
    SelectFrame SelectedFrame
    mnuFrameDelete.Enabled = (NumFrames > 1)
    DataModified = True
End Sub
' ************************************************
' Select a new frame.
' ************************************************
Private Sub SBar_Change()
    If SelectingFrame Then Exit Sub
    SelectFrame SBar.Value
End Sub
' ************************************************
' Select a new frame.
' ************************************************
Private Sub SBar_Scroll()
    SBar_Change
End Sub